home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
kcl.lha
/
cmpnew
/
cmptag.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-03
|
8KB
|
208 lines
;;; CMPTAG Tagbody and Go.
;;;
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
(in-package 'compiler)
(si:putprop 'tagbody 'c1tagbody 'c1special)
(si:putprop 'tagbody 'c2tagbody 'c2)
(si:putprop 'go 'c1go 'c1special)
(si:putprop 'go 'c2go 'c2)
(defstruct tag
name ;;; Tag name.
ref ;;; Referenced or not. T or NIL.
ref-clb ;;; Cross local function reference.
;;; During Pass1, T or NIL.
;;; During Pass2, the vs-address for the
;;; tagbody id, or NIL.
ref-ccb ;;; Cross closure reference.
;;; During Pass1, T or NIL.
;;; During Pass2, the vs-address for the
;;; block id, or NIL.
label ;;; Where to jump. A label.
unwind-exit ;;; Where to unwind-no-exit.
var ;;; The tag-name holder. A VV index.
)
(defvar *tags* nil)
;;; During Pass 1, *tags* holds a list of tag objects and the symbols 'CB'
;;; (Closure Boundary) and 'LB' (Level Boundary). 'CB' will be pushed on
;;; *tags* when the compiler begins to process a closure. 'LB' will be pushed
;;; on *tags* when *level* is incremented.
(defun c1tagbody (body &aux (*tags* *tags*) (info (make-info)))
;;; Establish tags.
(setq body
(mapcar
#'(lambda (x)
(cond ((or (symbolp x) (integerp x))
(let ((tag (make-tag :name x :ref nil
:ref-ccb nil :ref-clb nil)))
(push tag *tags*)
tag))
(t x)))
body))
;;; Process non-tag forms.
(setq body (mapcar #'(lambda (x) (if (typep x 'tag) x (c1expr* x info)))
body))
;;; Delete redundant tags.
(do ((l body (cdr l))
(body1 nil) (ref nil) (ref-clb nil) (ref-ccb nil))
((endp l)
(if (or ref-ccb ref-clb ref)
(list 'tagbody info ref-clb ref-ccb (reverse body1))
(list 'progn info (reverse (cons (c1nil) body1)))))
(declare (object l ref ref-clb ref-ccb))
(if (typep (car l) 'tag)
(cond ((tag-ref-ccb (car l))
(push (car l) body1)
(setf (tag-var (car l)) (add-object (tag-name (car l))))
(setq ref-ccb t))
((tag-ref-clb (car l))
(push (car l) body1)
(setf (tag-var (car l)) (add-object (tag-name (car l))))
(setq ref-clb t))
((tag-ref (car l)) (push (car l) body1) (setq ref t)))
(push (car l) body1))))
(defun c2tagbody (ref-clb ref-ccb body)
(cond (ref-ccb (c2tagbody-ccb body))
(ref-clb (c2tagbody-clb body))
(t (c2tagbody-local body))))
(defun c2tagbody-local (body &aux (label (next-label)))
;;; Allocate labels.
(dolist** (x body)
(when (typep x 'tag)
(setf (tag-label x) (next-label*))
(setf (tag-unwind-exit x) label)))
(let ((*unwind-exit* (cons label *unwind-exit*)))
(c2tagbody-body body))
)
(defun c2tagbody-body (body)
(do ((l body (cdr l)) (written nil))
((endp (cdr l))
(cond (written (unwind-exit nil))
((typep (car l) 'tag)
(wt-label (tag-label (car l)))
(unwind-exit nil))
(t (let* ((*exit* (next-label))
(*unwind-exit* (cons *exit* *unwind-exit*))
(*value-to-go* 'trash))
(c2expr (car l))
(wt-label *exit*))
(unless (eq (caar l) 'go) (unwind-exit nil)))))
(declare (object l written))
(cond (written (setq written nil))
((typep (car l) 'tag) (wt-label (tag-label (car l))))
(t (let* ((*exit* (if (typep (cadr l) 'tag)
(progn (setq written t) (tag-label (cadr l)))
(next-label)))
(*unwind-exit* (cons *exit* *unwind-exit*))
(*value-to-go* 'trash))
(c2expr (car l))
(wt-label *exit*))))))
(defun c2tagbody-clb (body &aux (label (next-label)) (*vs* *vs*))
(let ((*unwind-exit* (cons 'frame *unwind-exit*))
(ref-clb (vs-push)))
(wt-nl) (wt-vs ref-clb) (wt "=alloc_frame_id();")
(wt-nl "frs_push(FRS_CATCH,") (wt-vs ref-clb) (wt ");")
(wt-nl "if(nlj_active){")
(wt-nl "nlj_active=FALSE;")
;;; Allocate labels.
(dolist** (tag body)
(when (typep tag 'tag)
(setf (tag-label tag) (next-label))
(setf (tag-unwind-exit tag) label)
(when (tag-ref-clb tag)
(setf (tag-ref-clb tag) ref-clb)
(wt-nl "if(eql(nlj_tag,VV[" (tag-var tag) "]))")
(wt-go (tag-label tag)))))
(wt-nl "FEerror(\"The GO tag ~s is not established.\",1,nlj_tag);")
(wt-nl "}")
(let ((*unwind-exit* (cons label *unwind-exit*)))
(c2tagbody-body body))))
(defun c2tagbody-ccb (body &aux (label (next-label))
(*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*))
(let ((*unwind-exit* (cons 'frame *unwind-exit*))
(ref-clb (vs-push)) ref-ccb)
(wt-nl) (wt-vs ref-clb) (wt "=alloc_frame_id();")
(wt-nl) (wt-vs ref-clb) (wt "=MMcons(") (wt-vs ref-clb) (wt ",")
(wt-clink) (wt ");")
(clink ref-clb)
(setq ref-ccb (ccb-vs-push))
(wt-nl "frs_push(FRS_CATCH,") (wt-vs* ref-clb) (wt ");")
(wt-nl "if(nlj_active){")
(wt-nl "nlj_active=FALSE;")
;;; Allocate labels.
(dolist** (tag body)
(when (typep tag 'tag)
(setf (tag-label tag) (next-label*))
(setf (tag-unwind-exit tag) label)
(when (or (tag-ref-clb tag) (tag-ref-ccb tag))
(setf (tag-ref-clb tag) ref-clb)
(when (tag-ref-ccb tag) (setf (tag-ref-ccb tag) ref-ccb))
(wt-nl "if(eql(nlj_tag,VV[" (tag-var tag) "]))")
(wt-go (tag-label tag)))))
(wt-nl "FEerror(\"The GO tag ~s is not established.\",1,nlj_tag);")
(wt-nl "}")
(let ((*unwind-exit* (cons label *unwind-exit*)))
(c2tagbody-body body))))
(defun c1go (args)
(cond ((endp args) (too-few-args 'go 1 0))
((not (endp (cdr args))) (too-many-args 'go 1 (length args)))
((not (or (symbolp (car args)) (integerp (car args))))
"The tag name ~s is not a symbol nor an integer." (car args)))
(do ((tags *tags* (cdr tags))
(name (car args))
(ccb nil) (clb nil))
((endp tags) (cmperr "The tag ~s is undefined." name))
(declare (object name ccb clb))
(case (car tags)
(cb (setq ccb t))
(lb (setq clb t))
(t (when (eq (tag-name (car tags)) name)
(let ((tag (car tags)))
(cond (ccb (setf (tag-ref-ccb tag) t))
(clb (setf (tag-ref-clb tag) t))
(t (setf (tag-ref tag) t)))
(return (list 'go *info* clb ccb tag))))))))
(defun c2go (clb ccb tag)
(cond (ccb (c2go-ccb tag))
(clb (c2go-clb tag))
(t (c2go-local tag))))
(defun c2go-local (tag)
(unwind-no-exit (tag-unwind-exit tag))
(wt-nl) (wt-go (tag-label tag)))
(defun c2go-clb (tag)
(wt-nl "vs_base=vs_top;")
(wt-nl "unwind(frs_sch(")
(if (tag-ref-ccb tag)
(wt-vs* (tag-ref-clb tag))
(wt-vs (tag-ref-clb tag)))
(wt "),VV[" (tag-var tag) "]);"))
(defun c2go-ccb (tag)
(wt-nl "{frame_ptr fr;")
(wt-nl "fr=frs_sch(") (wt-ccb-vs (tag-ref-ccb tag)) (wt ");")
(wt-nl "if(fr==NULL)FEerror(\"The GO tag ~s is missing.\",1,VV["
(tag-var tag) "]);")
(wt-nl "vs_base=vs_top;")
(wt-nl "unwind(fr,VV[" (tag-var tag) "]);}"))